home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual BASIC 5.0 (Ent. Edition) / Vb5ent Extractor.EXE / VB / SAMPLES / PGUIDE / GEOFACTS / GEOFACTS.BAS next >
Encoding:
BASIC Source File  |  1996-10-15  |  4.1 KB  |  125 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3.  
  4. Public wbWorld As Excel.Workbook
  5. Public shtWorld As Excel.Worksheet
  6.  
  7. Sub Setup()
  8.     ChDir App.Path
  9.     ChDrive App.Path
  10.     ' Get the first sheet in WORLD.XLS.
  11.     Set shtWorld = GetObject("world.xls")
  12.     ' Get the workbook.
  13.     Set wbWorld = shtWorld.Application.Workbooks("world.xls")
  14. End Sub
  15.  
  16. ' Set the objects to Nothing.
  17. Sub CleanUp()
  18.     ' This should force an unload of Microsoft Excel,
  19.     ' providing no other applications or users have it loaded.
  20.     Set shtWorld = Nothing
  21.     Set wbWorld = Nothing
  22. End Sub
  23.  
  24. ' Fill the Continents combo box with the names
  25. ' of the sheets in the workbook.
  26. Sub FillContinentsList()
  27.     Dim shtContinent As Excel.Worksheet
  28.     
  29.     ' Iterate through the collection of sheets and add
  30.     ' the name of each sheet to the combo box.
  31.     For Each shtContinent In wbWorld.Sheets
  32.         frmGeoFacts.cmbContinents.AddItem shtContinent.Name
  33.     Next
  34.     ' Select the first item and display it in the combo box.
  35.     frmGeoFacts.cmbContinents.Text = frmGeoFacts.cmbContinents.List(0)
  36.  
  37.     Set shtContinent = Nothing
  38. End Sub
  39.  
  40. ' Fill the Continents combo box with the names
  41. ' of the features corresponding to a given continent.
  42. Sub FillFeaturesList()
  43.     Dim shtContinent As Excel.Worksheet
  44.     Dim rngFeatureList As Excel.Range
  45.     Dim intFirstBlankCell As Integer
  46.     Dim loop1 As Integer
  47.  
  48.     ' Hide the old ranking list.
  49.     frmGeoFacts.lstTopRanking.Visible = False
  50.     
  51.     ' Get the sheet with the name of the continent selected in the Continents combo box.
  52.     Set shtContinent = wbWorld.Sheets(frmGeoFacts.cmbContinents.Text)
  53.     ' Assign the first row of this sheet to an object.
  54.     Set rngFeatureList = shtContinent.Rows(1)
  55.     
  56.     ' See if it's an empty list.
  57.     If (rngFeatureList.Cells(1, 1) = "") Then
  58.         intFirstBlankCell = 0
  59.     Else
  60.         ' Search the row for the first blank cell.
  61.         intFirstBlankCell = rngFeatureList.Find("").Column
  62.     End If
  63.     
  64.     ' Empty the previous contents of the features combo box.
  65.     frmGeoFacts.cmbFeatures.Clear
  66.             
  67.     ' Add the items to the features combo box.
  68.     For loop1 = 1 To intFirstBlankCell
  69.             frmGeoFacts.cmbFeatures.AddItem rngFeatureList.Cells(1, loop1)
  70.     Next
  71.     
  72.     ' Select the first item and display it in the combo box.
  73.     frmGeoFacts.cmbFeatures.Text = frmGeoFacts.cmbFeatures.List(0)
  74.  
  75.     ' Clean up.
  76.     Set shtContinent = Nothing
  77.     Set rngFeatureList = Nothing
  78. End Sub
  79.  
  80. ' Fill the list of ranking items.
  81. Sub FillTopRankingList()
  82.     Dim shtContinent As Excel.Worksheet
  83.     Dim intColumOfFeature As Integer
  84.     Dim rngRankedList As Excel.Range
  85.     Dim intFirstBlankCell As Integer
  86.     Dim loop1 As Integer
  87.     
  88.     ' Get the sheet with the name of the continent selected in the Continents combo box.
  89.     Set shtContinent = wbWorld.Sheets(frmGeoFacts.cmbContinents.Text)
  90.     
  91.     ' Empty the previous contents of the ranking list box.
  92.     frmGeoFacts.lstTopRanking.Clear
  93.     
  94.     ' If the feature selection is blank, do nothing.
  95.     If (frmGeoFacts.cmbFeatures <> "") Then
  96.         
  97.         ' Look up the column of the selected feature in the first row of the spreadsheet.
  98.         intColumOfFeature = shtContinent.Rows(1).Find(frmGeoFacts.cmbFeatures.Text).Column
  99.         
  100.         ' Assign the column to an object.
  101.          Set rngRankedList = shtContinent.Columns(intColumOfFeature)
  102.         
  103.         ' See if it's a blank list.
  104.         If (rngRankedList.Cells(1, 1) = "") Then
  105.             intFirstBlankCell = 0
  106.         Else
  107.             ' Search the row for the first blank cell.
  108.             intFirstBlankCell = rngRankedList.Find("").Row
  109.         End If
  110.                 
  111.         ' Add the items to the TopRanking ListBox.
  112.         For loop1 = 2 To intFirstBlankCell
  113.             frmGeoFacts.lstTopRanking.AddItem rngRankedList.Cells(loop1, 1)
  114.         Next
  115.     
  116.         ' Show the new ranking list.
  117.         frmGeoFacts.lstTopRanking.Visible = True
  118.     
  119.     End If
  120.     
  121.     ' Clean up.
  122.     Set shtContinent = Nothing
  123.     Set rngRankedList = Nothing
  124. End Sub
  125.